(define-module (Z572 packages)
  #:use-module (guix packages)
  #:use-module (ice-9 match)
  #:use-module (guix git-download)
  #:use-module (guix download)
  #:use-module ((guix licenses) #:prefix license:)
  #:export (package* modifyed-package))

(eval-when (expand load eval)
  (define-syntax package*
    (lambda (x)
      (syntax-case x ()
        ((_ (it origin) (others ...) ...)
         (and (identifier? #'it))
         #'(let ((it origin))
             (package
               (inherit it)
               (others ...) ...)))
        ((_ () (others ...) ...)
         #'(package (others ...) ...)))))

  (define-syntax modifyed-package
    (lambda (x)
      (define (oo symbol changed-name body origin)
        #`(#,symbol
           (let ((#,changed-name
                              ;;; hack to thunked and delayed field
                  (let ((o ((record-accessor (record-type-descriptor #,origin)
                                             '#,symbol)
                            #,origin)))
                    (cond ((procedure? o)
                           (o #,origin))
                          ((promise? o)
                           (force o))
                          (else o)))))
             #,body) ))
      (syntax-case x ()

        ((_ (it origin) (name b) ...)
         (and (identifier? #'it)
              (and-map (lambda (o)
                         (syntax-case o ()
                           (( symbol changed-name)
                            (and (identifier? #'symbol)
                                 (identifier? #'changed-name)))
                           (symbol (identifier? #'symbol))))
                       #'(name ...)))
         (let loop ((names #'(name ...))
                    (bodys #'(b ...))
                    (arguments '()))
           (if (null? names)
               #`(package* (it origin)
                   #,@(reverse arguments))
               (syntax-case (car names) ()
                 ((symbol changed-name)
                  (and (identifier? #'symbol)
                       (identifier? #'changed-name))
                  (loop (cdr names)
                        (cdr bodys)
                        (cons (oo #'symbol #'changed-name (car bodys) #'origin)
                              arguments)))
                 (v
                  (identifier? #'v)
                  (loop (cdr names)
                        (cdr bodys)
                        (cons (oo #'v #'v (car bodys) #'origin)
                              arguments)))))))))))
